perm filename BBX.F4[MSS,LCS] blob sn#249491 filedate 1976-11-27 generic text, type T, neo UTF8
00100		SUBROUTINE PT2
00200		INTEGER VALID
00300		DIMENSION VALID(6),BARS(1),JBAR(1),JRN(1),MBAR(1)
00400		DATA JLINE/140/,HX/2./,VALID/1,4,8,2,3,-2/,SLSP/11.0/,DIV/4./
00500	C  JLINE=BASIC LINE LENGTH, HX=HEIGHT MULTIPLIER, ZL=LN. LNGTH FACTOR.
00600	
00700	C  ADD MORE TO VALID LATER *****
00800		COMMON /FIN/LBAR,METR,REND,KPX,KREAD,JEND,JSLUR,JSL2,NAMZ
00900		1,LC,LPG,MPG,CLEF,SIG,LB,SPG,MTR1,MTR2 /MNX/MIN,MAX,JT
01000		COMMON /SF/KL,RT,KP,STFSZ,NAMX /IPG/IPG,JPG,BRACK,
01100		1 RSTNUM(8),RPSZ(8),RHGT(8),RCLEF(-3/4) /KBAR/KBAR(512) 
01200		1 /RSP/KNM(10),ENDLN,N,NAME,NMPG,T
01300		COMMON RS,JA,RA,R,RB,RQ(15),KQ,NQ,JQ,JJQ,KBQ,NAQ
01400		COMMON/STF/RSTFAC(-3/4),RSTJ2 /IVV/IV(1) /SIZE/SIZE
01500		COMMON /POSI/STFF(-3/4),JJ2,JPQ /LLL/L,ITRANS,I,RXQ
01600		1/PX/KPN(1) /Q/Q(1) /PTR/KWDS(1) /XRN/RN(1) /NBAR/NBAR(50)
01700		EQUIVALENCE (RQ(2),R4),(R5,RQ(3)),(R6,RQ(4)),(R7,RQ(5)),(KT,KBAR)
01800		1,(R8,RQ(6)),(R9,RQ(7)),(JRN,RN),(MBAR,RN(1000))
01900		1,(LCNT,IV(45)),(NDPY,IV(46)),(TOT,KBAR(2)),(JBAR,BARS,KBAR(4))
02000	C  TRNSP'S Bb, F, BBb, A, G, Eb.
02100	145	FORMAT(F,2I)
02200	CCC	IF(RS.NE.'OLD')GO TO 2000
02300		CALL GETEXT('BARS','PAG')
02400		CALL EXTIN(KBAR,512)
02500		CALL EXTIN(RSTFAC,128)
02600	2000	TYPE 144,RSTJ2
02700	CC144	FORMAT(' STAFF SIZE, TRANSP.  '$)
02800	144	FORMAT(' STAFF SIZE='F4.2,'  CHANGE TO '$)
02900		ACCEPT 145,SIZE,ITRANS
03000		DSK=0
03100	C  ****** TEMPORARY ******  DSK 
03200		IF(ITRANS.NE.0)DSK=-1
03300		IF(SIZE.EQ.0)SIZE=RSTJ2
03400		SIZE=SIZE/RSTJ2 
03500	101	JTOT=0
03600		ITOT=0
03700		DO 22 K=1,KT
03800		JJ=BARS(K)*SIZE+.5
03900		ITOT=ITOT+JJ
04000		JBAR(K)=JJ
04100	22	JTOT=JTOT+JJ
04200		ITOT=TOT*SIZE
04300	CC22	JBAR(K)=BARS(K)*SIZE+.5
04400	CC	TOT=TOT*SIZE
04500	33	IF(RSTJ2.EQ.0)RSTJ2=1 
04600		RA=JPG*SIZE*RSTJ2
04700		MPG=10./RA
04800	C  MPG=NUM OF BRACES PER PAGE.
04900		SPG=10./MPG
05000	C  SPG IS SPACE TO BE SET ABOVE STAFF 0
05100		RS=SIZE*17
05200		RA=(RSTJ2*SIZE)/RPSZ(1)
05300		DO 141 K=1,JPG
05400		RB=RSTNUM(K)-1
05500	C  ADJUSTS DIST. BETWEEN STAVES DEPENDING ON SIZE FACTOR.
05600		RHGT(K)=RHGT(K)+RB*(RS-17)
05700	141	RPSZ(K)=RPSZ(K)*RA
05800		LPG=JPG
05900		IF(MOD(ITRANS,7).EQ.0)GO TO 140
06000		DO 40 L=1,6
06100	40	IF(ITRANS.EQ.VALID(L))GO TO 140
06200		TYPE 240
06300		GO TO 2000
06400	240	FORMAT(' THIS TRANSP NOT OFFERED')
06500	
06600	140	TYPE 90,KT
06700		RA=0
06800	90	FORMAT(' TOTAL BAR LINES='I3/' NUMBER OF BARS PER LINE')
06900		
07000		JT=ITOT/JLINE
07100	C  USE JLINE (140 FOR NOW) AS SUGGESTED LINE LENGTH
07200	16	NT=JT
07300		L=0
07400	CC	JTOT=TOT+.5
07500		KTOT=JTOT
07600		KAV=JTOT/JT
07700	
07800		LMIN=-1
07900		LMAX=10000
08000		LJ=0
08100		NJ=0
08200		LMM=-1
08300		LDIF=10000
08400		NBAR(1)=1
08500		J=1
08600	3	M=1
08700		JAV=KTOT/NT
08800		K=JBAR(J)
08900	1	J=J+1
09000		IF(J.GT.KT)GO TO 2
09100		N=JBAR(J)
09200		IF(K+N/2.GE.JAV)GO TO 2
09300		M=M+1
09400		K=K+N
09500		GO TO 1
09600	2	L=L+1
09700		KTOT=KTOT-K
09800		NT=NT-1
09900		JRN(L)=K
10000		NBAR(L+1)=J
10100		IF(NT.GT.0)GO TO 3
10200	5	MAX=0
10300		MIN=10000
10400	
10500		DO 7 L=1,JT
10600		K=JRN(L)
10700		IF(K.LE.MAX)GO TO 6
10800		MAX=K
10900		MX=L
11000	6	IF(K.GE.MIN)GO TO 7
11100		MIN=K
11200		MN=L
11300	7	CONTINUE
11400	
11500		J=MAX-MIN
11600		IF(MAX.GE.LMAX.AND.J.GE.LDIF)GO TO 9
11700		IF(MIN.GT.LMIN)LMIN=MIN
11800		IF(MAX.LT.LMAX)LMAX=MAX
11900		IF(J.LT.LDIF)LDIF=J
12000		CALL STORE
12100	C  SAVE NBAR INFO IN MBAR
12200	
12300		IF(MX.LT.MN)GO TO 32
12400		JJ=0
12500		JM=-1
12600		JK=1
12700	23	K=NBAR(MX+JJ)-JJ
12800	C NEXT RIPPLES THE BARS, FROM MAX TO MIN.
12900		MM=JBAR(K)
13000		JRN(MX)=JRN(MX)-MM
13100		JRN(MX+JM)=JRN(MX+JM)+MM
13200		NBAR(MX+JJ)=K+JK
13300		MX=MX+JM
13400		IF(JJ.NE.0)GO TO 223
13500		IF(MX.GT.MN)GO TO 23
13600		GO TO 5 
13700	223	IF(MX.LT.MN)GO TO 23
13800		GO TO 5 
13900	32	JJ=1
14000		JM=1
14100		JK=0
14200		GO TO 23
14300	9	CALL GET
14400		IDIF=10000
14500		JJT=JT-1
14600	104	CALL MNMX(IDIF)
14700	108	DO 102 J=1,JJT
14800		IF(JRN(J).LE.KAV)GO TO  102
14900	C DON'T MAKE IT SMALLER IF IT'S ALREADY LESS THAN AVERAGE.
15000		I=NBAR(J+1)-1
15100		IF(I.EQ.NBAR(J))GO TO 102
15200	C WE'RE DOWN TO ONE BAR
15300		JJ=JRN(J)-JBAR(I)
15400	C SUBTRACT LAST BAR OF THIS LINE, ADD IT ON NEXT.
15500		IF(JJ.LT.MIN)GO TO 102
15600		KK=JRN(J+1)+JBAR(I)
15700		IF(KK.GT.MAX)GO TO 103
15800	C LET'S SEE IF FURTHER SHUFFLING WILL IMPROVE IT.
15900		CALL MINMAX
16000	105	JRN(J)=JJ
16100		JRN(J+1)=KK
16200		NBAR(J+1)=NBAR(J+1)-1
16300		GO TO 104
16400	103	IF(J.EQ.JJT)GO TO 102
16500		NN=KK
16600		DO 106 K=J+1,JJT
16700		LL=NBAR(K+1)-1
16800	C CHECK ON WHAT WILL HAPPEN TO NEXT LINE.
16900		MM=NN-JBAR(LL)
17000		IF(MM.LT.MIN.OR.MM.GT.MAX)GO TO 102
17100		NN=JBAR(LL)+JRN(K+1)
17200	106	IF(NN.LE.MAX)GO TO 105
17300	102	CONTINUE
17400	204	CALL MNMX(IDIF)
17500	208	DO 202 J=JT,2,-1
17600		IF(JRN(J).LE.KAV)GO TO  202
17700	C DON'T MAKE IT SMALLER IF IT'S ALREADY LESS THAN AVERAGE.
17800		I=NBAR(J)
17900		IF(I-1.EQ.NBAR(J-1))GO TO 202
18000	C WE'RE DOWN TO ONE BAR
18100		JJ=JRN(J)-JBAR(I)
18200	C SUBTRACT LAST BAR OF THIS LINE, ADD IT ON NEXT.
18300		IF(JJ.LT.MIN)GO TO 202
18400		KK=JRN(J-1)+JBAR(I)
18500		IF(KK.GT.MAX)GO TO 203
18600	C LET'S SEE IF FURTHER SHUFFLING WILL IMPROVE IT.
18700		CALL MINMAX
18800	205	JRN(J)=JJ
18900		JRN(J-1)=KK
19000		NBAR(J)=NBAR(J)+1
19100		GO TO 204
19200	203	IF(J.EQ.2)GO TO 202
19300		NN=KK
19400		DO 206 K=J-1,2,-1
19500		LL=NBAR(K)
19600	C CHECK ON WHAT WILL HAPPEN TO NEXT LINE.
19700		MM=NN-JBAR(LL)
19800		IF(MM.LT.MIN.OR.MM.GT.MAX)GO TO 202
19900		NN=JBAR(LL)+JRN(K-1)
20000	206	IF(NN.LE.MAX)GO TO 205
20100	202	CONTINUE
20200	
20300		CALL MINMAX
20400		IDIF=MAX-MIN
20500		CALL STORE
20600	400	MX=MAX+5
20700		JR=1
20800	C  JR = HOW MANY BARS TO RIPPLE
20900		I=MAX-MIN
21000		IF(I.GT.IDIF)GO TO 402
21100		CALL STORE(JT)
21200		IDIF=I
21300	402	DO 401 J=1,JT
21400	401	IF(JRN(J).EQ.MIN)GO TO 408
21500	C  TRY RIPPLE EACH WAY FROM SMALLEST VALUE
21600	408	IF(J.EQ.JT)GO TO 508
21700	C RIPPLE FORWARD FIRST
21800		I=NBAR(J+1)
21900		JJ=JRN(J)+JBAR(I)
22000		IF(JJ.GT.MX)GO TO 508
22100	C SMALLEST ISN'T TOO BIG, NOW CHECK UP THE LINE.
22200		NN=JRN(J+1)-JBAR(I)
22300		IF(NN.LT.MIN)GO TO 404
22400	C IF WE GET HERE THERE HAS BEEN IMPROVEMENT
22500		JRN(J)=JJ
22600		JRN(J+1)=NN
22700		NBAR(J+1)=I+1
22800	415	CALL MINMAX
22900	C NOW GO BACK AND TRY AGAIN.
23000		GO TO 400
23100	
23200	405	JRN(J)=JJ
23300	
23400		DO 422 IB=J+1,N
23500		LB=NBAR(IB)
23600		JB=JRN(IB)-JBAR(LB)
23700		NBAR(IB)=LB+1
23800		IF(JB.LT.MIN)GO TO 421
23900		JRN(IB)=JB
24000		GO TO 415
24100	
24200	421	IBB=IB+1
24300		LC=NBAR(IBB)
24400		JB=JB+JBAR(LC)
24500		IF(JB.GT.MIN)GO TO 422
24600	C NOW ADD A SECOND BAR
24700		JRN(IBB)=JRN(IBB)-JBAR(LC)
24800		LC=LC+1
24900		JB=JB+JBAR(LC)
25000		NBAR(IBB)=LC
25100	
25200	422	JRN(IB)=JB
25300		NBAR(IBB)=LC+1
25400		JRN(IBB)=JRN(IBB)-JBAR(LC)
25500		GO TO 415
25600	C NOW GO BACK AND TRY AGAIN.
25700		
25800	404	IF(J.EQ.JJT)GO TO 508
25900		DO 406 N=J+1,JJT
26000	  	LL=NBAR(N+1)
26100		MM=NN+JBAR(LL)
26200		IF(MM.GT.MX)GO TO 508
26300		IF(MM.GT.MIN)GO TO 409
26400	C NEXT TO RIPPLE 2 BARS!
26500	412	MN=MM+JBAR(LL+1)
26600	C  ADD ON A SECOND BAR
26700		IF(MN.GT.MX)GO TO 508
26800	C DON'T WORRY ABOUT IT BEING TOO SMALL (YET)
26900		NN=JRN(N+1)-JBAR(LL)-JBAR(LL+1)
27000		IF(NN.GT.MIN)GO TO 405
27100		GO TO 406
27200	
27300	409	NN=JRN(N+1)-JBAR(LL)
27400		IF(NN.GE.MIN)GO TO 405
27500	406	CONTINUE
27600	
27700	C  TRY RIPPLE EACH WAY FROM SMALLEST VALUE
27800	508	IF(J.EQ.1)GO TO 502
27900		IF(J.NE.LJ)GO TO 150
27950		IF(MX-MN.EQ.LMM)GO TO 502
28000	C THIS SHOULD AVOID GETTING INTO A LOOP
28100	150	LJ=J
28200		LMM=MX-MN
28300	C RIPPLE BACK NOW
28400		I=NBAR(J)-1
28500		JJ=JRN(J)+JBAR(I)
28600		IF(JJ.GT.MX)GO TO 502
28700	C SMALLEST ISN'T TOO BIG, NOW CHECK UP THE LINE.
28800		NN=JRN(J-1)-JBAR(I)
28900		IF(NN.LT.MIN)GO TO 504
29000	C IF WE GET HERE THERE HAS BEEN IMPROVEMENT
29100		JRN(J)=JJ
29200		JRN(J-1)=NN
29300		NBAR(J)=I
29400		GO TO 415
29500	505	JRN(J)=JJ
29600		DO 522 IB=J-1,N,-1
29700		LB=NBAR(IB+1)-1
29800		JB=JRN(IB)-JBAR(LB)
29900		NBAR(IB+1)=LB
30000		IF(JB.LT.MIN)GO TO 521
30100		JRN(IB)=JB
30200		GO TO 415
30300	521	IBB=IB-1
30400		LC=NBAR(IB)-1
30500		JB=JB+JBAR(LC)
30600		IF(JB.GT.MIN)GO TO 522
30700		JB=JB+JBAR(LC-1)
30800		NBAR(IB)=LC
30900		JRN(IBB)=JRN(IBB)-JBAR(LC)
31000	CHECK THIS OUT!!
31100		LC=LC-1
31200	522	JRN(IB)=JB
31300		JRN(IBB)=JRN(IBB)-JBAR(LC)
31400		NBAR(IB)=LC
31500		GO TO 415
31600	504	IF(J.LE.2)GO TO 502
31700		DO 506 N=J-1,2,-1
31800	 	LL=NBAR(N)-1
31900		MM=NN+JBAR(LL)
32000		IF(MM.GT.MX)GO TO 502
32100		IF(MM.GT.MIN)GO TO 509
32200	512	MN=MM+JBAR(LL-1)
32300		IF(MN.GT.MX)GO TO 502
32400		NN=JRN(N-1)-JBAR(LL)-JBAR(LL-1)
32500		IF(NN.GT.MIN)GO TO 505
32600		GO TO 506
32700	509	NN=JRN(N-1)-JBAR(LL)
32800		IF(NN.GE.MIN)GO TO 505
32900	506	CONTINUE
33000	502	IF(J.EQ.NJ.AND.MX-MN.EQ.LMM)GO TO 515
33100	C  CHECK TO AVOID ENDLESS LOOP.
33200		NJ=J
33300		IF(J.EQ.JT)GO TO 515
33400	C LOOK FOR OTHER LINES = MIN.
33500		DO 510 K=J+1,JT
33600		IF(JRN(K).NE.MIN)GO TO 510
33700		J=K
33800		GO TO 408
33900	510	CONTINUE
34000	
34100	515	CALL GET
34200	
34300	13	DO 14 L=2,JT
34400		K=NBAR(L)
34500		MM=JRN(L)
34600		KK=JRN(L-1)
34700		IF(MM.GE.KK)GO TO 12
34800	C  JUGGLES ADJACENT LINES
34900		N=JBAR(K-1)
35000		IF(KK-MM.LT.N)GO TO 14
35100		JRN(L-1)=KK-N
35200		JRN(L)=MM+N
35300		NBAR(L)=K-1
35400		GO TO 13
35500	12	N=JBAR(K)
35600		IF(MM-KK.LE.N)GO TO 14
35700		JRN(L-1)=KK+N
35800		JRN(L)=MM-N
35900		NBAR(L)=K+1
36000		GO TO 13
36100	14	CONTINUE
36200	46	J=1
36300		NBAR(JT+1)=KT+1
36400		JAV=JTOT/JT
36500		CALL MINMAX
36600		TYPE 308,JAV,MIN,MAX
36700		IF(DSK)WRITE(21,308)JAV,MIN,MAX
36800	307	DO 305 K=1,JT
36900		NBAR(K)=NBAR(K+1)-NBAR(K)
37000	C NBAR NOW HAS NUM. OF BARS PER LINE.
37100		L=NBAR(K)-1+J
37200	308	FORMAT(' AVG=',I3,'  MIN=',I3,'  MAX=',I3)
37300	306	FORMAT(I5,3X8I5)
37400		TYPE 306,JRN(K),(JBAR(N),N=J,L)
37500		IF(DSK)WRITE(21,306)JRN(K),(JBAR(N),N=J,L)
37600	305	J=L+1
37700		NBAR(JT+1)=0
37800		
37900		RPG=JT
38000		RPG=RPG/MPG
38100	605	TYPE 604,RPG,JT
38200		IF(DSK)WRITE(21,104)RPG,JT
38300	604	FORMAT(F5.2,' PAGES',/,I4,' LINES - OR TYPE N1, N2 --'$)
38400	C  FOR SPECIFICATION OF HOW MANY BARS ON EACH LINE
38500		KA=0
38600		ACCEPT 145,T,N,KL
38700	C   TYPE 0,n  TO EXIT WITH n SPACING BETWEEN STAVES (2 IS DEFAULT)
38800		IF(KL.NE.0)GO TO 110
38900	C NO MORE THAN 36 NUMS, INCLUDING 0S (FOR PAGE MARKS)
39000		IF(T.EQ.0)GO TO 11
39100		JT=T
39200		IF(N.EQ.0)GO TO 16
39300	C N=0 MEANS T= NUM OF LINES DESIRED.
39400	
39500	111	FORMAT(36I)
39600	110	REREAD 111,NBAR
39700	911	DO 112 K=36,1,-1
39800		KP=NBAR(K)
39900		KA=KA+KP
40000	112	IF(KP.EQ.0.AND.KA.EQ.0)KL=K
40100		IF(KA.NE.KT)GO TO 605
40200	C  MISMATCH!
40300		N=26-2*MOD(KL-1,12)
40400		IF(N.EQ.26)N=0
40500	C  TO SPACE OUT STAVES VERTICALLY
40600	CC	IF(IPG)GO TO 11
40700	CC	IF(NBAR(1).NE.0)GO TO 11
40800	CC	DO 711 K=1,36
40900	CC	IF(K.GT.J)IV(K)=0
41000	CC711	NBAR(K)=IV(K)
41100	CC	GO TO 911
41200	11	CALL WRTPAG
41300		END
41400	
41500		SUBROUTINE MINMAX
41600		COMMON /MNX/MIN,MAX,JT /XRN/JRN(1)
41700		MIN=10000
41800		MAX=0
41900		DO 107 K=1,JT
42000		NN=JRN(K)
42100		IF(NN.LT.MIN)MIN=NN
42200	107	IF(NN.GT.MAX)MAX=NN
42300		END
42400	
42500		SUBROUTINE STORE
42600		COMMON /MNX/MIN,MAX,JT /XRN/JRN(1)/NBAR/NBAR(1)
42700		DIMENSION MB(1)
42800		EQUIVALENCE (MB,JRN(1000))
42900		DO 1 K=2,JT+1
43000	1	MB(K)=NBAR(K)
43100		END
43200	
43300		SUBROUTINE GET
43400		COMMON /MNX/MIN,MAX,JT /XRN/JRN(1)/NBAR/NBAR(1)/KBAR/KBAR(1) 
43500		DIMENSION MB(1),JBAR(1)
43600		EQUIVALENCE  (MB,JRN(1000)),(JBAR,KBAR(4))
43700		J=1
43800		DO 1 K=2,JT+1
43900		NBAR(K)=MB(K)
44000		N=0
44100		DO 2 L=J,MB(K)-1
44200	C FIX UP JRN ARRAY
44300	2	N=N+JBAR(L)
44400		JRN(K-1)=N
44500	1	J=MB(K)
44600		END
44700	
44800		SUBROUTINE MNMX(IDIF)
44900		COMMON /MNX/MIN,MAX,JT /XRN/JRN(1)
45000		L=MIN
45100	 	N=MAX
45200		CALL MINMAX
45300		J=MAX-MIN
45400		IF(J.LE.IDIF)GO TO 1
45500		MIN=L
45600		MAX=N
45700		RETURN
45800	1	IDIF=J
45900		END